home *** CD-ROM | disk | FTP | other *** search
/ Turnbull China Bikeride / Turnbull China Bikeride - Disc 2.iso / STUTTGART / FROMUTS / PERL / Perl / Lib / Perldb < prev    next >
Text File  |  1991-02-09  |  15KB  |  557 lines
  1. package DB;
  2.  
  3. $header = '$Header: perldb.pl,v 3.0.1.6 91/01/11 18:08:58 lwall Locked $';
  4. #
  5. # This file is automatically included if you do perl -d.
  6. # It's probably not useful to include this yourself.
  7. #
  8. # Perl supplies the values for @line and %sub.  It effectively inserts
  9. # a do DB'DB(<linenum>); in front of every place that can
  10. # have a breakpoint.  It also inserts a do 'perldb.pl' before the first line.
  11. #
  12. # $Log:    perldb.pl,v $
  13. # Revision 3.0.1.6  91/01/11  18:08:58  lwall
  14. # patch42: @_ couldn't be accessed from debugger
  15. # 
  16. # Revision 3.0.1.5  90/11/10  01:40:26  lwall
  17. # patch38: the debugger wouldn't stop correctly or do action routines
  18. # 
  19. # Revision 3.0.1.4  90/10/15  17:40:38  lwall
  20. # patch29: added caller
  21. # patch29: the debugger now understands packages and evals
  22. # patch29: scripts now run at almost full speed under the debugger
  23. # patch29: more variables are settable from debugger
  24. # 
  25. # Revision 3.0.1.3  90/08/09  04:00:58  lwall
  26. # patch19: debugger now allows continuation lines
  27. # patch19: debugger can now dump lists of variables
  28. # patch19: debugger can now add aliases easily from prompt
  29. # 
  30. # Revision 3.0.1.2  90/03/12  16:39:39  lwall
  31. # patch13: perl -d didn't format stack traces of *foo right
  32. # patch13: perl -d wiped out scalar return values of subroutines
  33. # 
  34. # Revision 3.0.1.1  89/10/26  23:14:02  lwall
  35. # patch1: RCS expanded an unintended $Header in lib/perldb.pl
  36. # 
  37. # Revision 3.0  89/10/18  15:19:46  lwall
  38. # 3.0 baseline
  39. # 
  40. # Revision 2.0  88/06/05  00:09:45  root
  41. # Baseline version 2.0.
  42. # 
  43. #
  44.  
  45. open(OUT,">RawVDU:");        # so we don't dongle stdout
  46. select(OUT);
  47. $| = 1;                # for DB'OUT
  48.  
  49. select(STDOUT);
  50. $| = 1;                # for real STDOUT
  51. $sub = '';
  52.  
  53. $header =~ s/.Header: ([^,]+),v(\s+\S+\s+\S+).*$/$1$2/;
  54. &outstr("\nLoading DB routines from $header\n\nEnter h for help.\n\n");
  55.  
  56. sub DB {
  57.     &save;
  58.     ($package, $filename, $line) = caller;
  59.     $usercontext = '($@, $!, $[, $,, $/, $\) = @saved;' .
  60.     "package $package;";        # this won't let them modify, alas
  61.     local(*dbline) = "_<$filename";
  62.     $max = $#dbline;
  63.     if (($stop,$action) = split(/\0/,$dbline{$line})) {
  64.     if ($stop eq '1') {
  65.         $signal |= 1;
  66.     }
  67.     else {
  68.         $evalarg = "\$DB'signal |= do {$stop;}"; &eval;
  69.         $dbline{$line} =~ s/;9($|\0)/$1/;
  70.     }
  71.     }
  72.     if ($single || $trace || $signal) {
  73.     &outstr("$package'") unless $sub =~ /'/;
  74.     &outstr("$sub($filename:$line):  " . $dbline[$line]);
  75.     for ($i = $line + 1; $i <= $max && $dbline[$i] == 0; ++$i) {
  76.         last if $dbline[$i] =~ /^\s*(}|#|\n)/;
  77.         &outstr("$sub($filename:$i):  " . $dbline[$i]);
  78.     }
  79.     }
  80.     $evalarg = $action, &eval if $action;
  81.     if ($single || $signal) {
  82.     $evalarg = $pre, &eval if $pre;
  83.     &outstr($#stack . " levels deep in subroutine calls!\n")
  84.         if $single & 4;
  85.     $start = $line;
  86.     while (&outstr("  DB<" . ($#hist+1) . "> "), $cmd=&gets) {
  87.         $single = 0;
  88.         $signal = 0;
  89.         $cmd eq '' && exit 0;
  90.         chop($cmd);
  91.         $cmd =~ s/\\$// && do {
  92.         &outstr("  cont: ");
  93.         $cmd .= &gets;
  94.         redo;
  95.         };
  96.         $cmd =~ /^q$/ && exit 0;
  97.         $cmd =~ /^$/ && ($cmd = $laststep);
  98.         push(@hist,$cmd) if length($cmd) > 1;
  99.         ($i) = split(/\s+/,$cmd);
  100.         eval "\$cmd =~ $alias{$i}", &outstr($@) if $alias{$i};
  101.         $cmd =~ /^h$/ && do {
  102.         &outstr("
  103. T               Stack trace.
  104. s               Single step.
  105. n               Next, steps over subroutine calls.
  106. r               Return from current subroutine.
  107. c [line]        Continue; optionally inserts a one-time-only breakpoint 
  108.                 at the specified line.
  109. <CR>            Repeat last n or s.
  110. l min+incr      List incr+1 lines starting at min.
  111. l min-max       List lines.
  112. l line          List line;
  113. l               List next window.
  114. -               List previous window.
  115. w line          List window around line.
  116. l subname       List subroutine.
  117. f filename      Switch to filename.
  118. /pattern/       Search forwards for pattern; final / is optional.
  119. ?pattern?       Search backwards for pattern.
  120. L               List breakpoints and actions.
  121. S               List subroutine names.
  122. t               Toggle trace mode.
  123. b [line] [condition]
  124.                 Set breakpoint; line defaults to the current execution line; 
  125.                 condition breaks if it evaluates to true, defaults to \'1\'.
  126. b subname [condition]
  127.                 Set breakpoint at first line of subroutine.
  128. d [line]        Delete breakpoint.
  129. D               Delete all breakpoints.
  130. a [line] command
  131.                 Set an action to be done before the line is executed.
  132.                 Sequence is: check for breakpoint, print line if necessary,
  133.                 do action, prompt user if breakpoint or step, evaluate line.
  134. A               Delete all actions.
  135. V [pkg [vars]]    List some (default all) variables in a package (default current).
  136. X [vars]    Same as \"V currentpackage [vars]\".
  137. < command       Define command before prompt.
  138. > command       Define command after prompt.
  139. ! number        Redo command (default previous command).
  140. ! -number       Redo number\'th to last command.
  141. H -number       Display last number commands (default all).
  142. q or ^D         Quit.
  143. p expr          Same as \"&DB'outstr(expr)\" in current package.
  144. = [alias value]    Define a command alias, or list current aliases.
  145. command         Execute as a perl statement in current package.
  146.  
  147. ");
  148.         next; };
  149.         $cmd =~ /^t$/ && do {
  150.         $trace = !$trace;
  151.         &outstr("Trace = ".($trace?"on":"off")."\n");
  152.         next; };
  153.         $cmd =~ /^S$/ && do {
  154.         foreach $subname (sort(keys %sub)) {
  155.             &outstr($subname . "\n");
  156.         }
  157.         next; };
  158.         $cmd =~ s/^X\b/V $package/;
  159.         $cmd =~ /^V$/ && do {
  160.         $cmd = 'V $package'; };
  161.         $cmd =~ /^V\s*(\S+)\s*(.*)/ && do {
  162.         $packname = $1;
  163.         @vars = split(' ',$2);
  164.         do 'dumpvar' unless defined &main'dumpvar;
  165.         if (defined &main'dumpvar) {
  166.             &main'dumpvar($packname,@vars);
  167.         }
  168.         else {
  169.             &DB'outstr("dumpvar not available.\n");
  170.         }
  171.         next; };
  172.         $cmd =~ /^f\s*(.*)/ && do {
  173.         $file = $1;
  174.         if (!$file) {
  175.             &outstr("The old f command is now the r command.\n");
  176.             &outstr("The new f command switches filenames.\n");
  177.             next;
  178.         }
  179.         if (!defined $_main{'_<' . $file}) {
  180.             if (($try) = grep(m#^_<.*$file#, keys %_main)) {
  181.             $file = substr($try,2);
  182.             print "\n$file:\n";
  183.             }
  184.         }
  185.         if (!defined $_main{'_<' . $file}) {
  186.             &outstr("There's no code here anything matching $file.\n");
  187.             next;
  188.         }
  189.         elsif ($file ne $filename) {
  190.             *dbline = "_<$file";
  191.             $max = $#dbline;
  192.             $filename = $file;
  193.             $start = 1;
  194.             $cmd = "l";
  195.         } };
  196.         $cmd =~ /^l\s*(['A-Za-z_]['\w]*)/ && do {
  197.         $subname = $1;
  198.         $subname = "main'" . $subname unless $subname =~ /'/;
  199.         $subname = "main" . $subname if substr($subname,0,1) eq "'";
  200.         ($file,$subrange) = split(/:/,$sub{$subname});
  201.         if ($file ne $filename) {
  202.             *dbline = "_<$file";
  203.             $max = $#dbline;
  204.             $filename = $file;
  205.         }
  206.         if ($subrange) {
  207.             if (eval($subrange) < -$window) {
  208.             $subrange =~ s/-.*/+/;
  209.             }
  210.             $cmd = "l $subrange";
  211.         } else {
  212.             &outstr("Subroutine $1 not found.\n");
  213.             next;
  214.         } };
  215.         $cmd =~ /^w\s*(\d*)$/ && do {
  216.         $incr = $window - 1;
  217.         $start = $1 if $1;
  218.         $start -= $preview;
  219.         $cmd = 'l ' . $start . '-' . ($start + $incr); };
  220.         $cmd =~ /^-$/ && do {
  221.         $incr = $window - 1;
  222.         $cmd = 'l ' . ($start-$window*2) . '+'; };
  223.         $cmd =~ /^l$/ && do {
  224.         $incr = $window - 1;
  225.         $cmd = 'l ' . $start . '-' . ($start + $incr); };
  226.         $cmd =~ /^l\s*(\d*)\+(\d*)$/ && do {
  227.         $start = $1 if $1;
  228.         $incr = $2;
  229.         $incr = $window - 1 unless $incr;
  230.         $cmd = 'l ' . $start . '-' . ($start + $incr); };
  231.         $cmd =~ /^l\s*(([\d\$\.]+)([-,]([\d\$\.]+))?)?/ && do {
  232.         $end = (!$2) ? $max : ($4 ? $4 : $2);
  233.         $end = $max if $end > $max;
  234.         $i = $2;
  235.         $i = $line if $i eq '.';
  236.         $i = 1 if $i < 1;
  237.         for (; $i <= $end; $i++) {
  238.             &outstr("$i:  " . $dbline[$i]);
  239.             last if $signal;
  240.         }
  241.         $start = $i;    # remember in case they want more
  242.         $start = $max if $start > $max;
  243.         next; };
  244.         $cmd =~ /^D$/ && do {
  245.         &outstr("Deleting all breakpoints...\n");
  246.         for ($i = 1; $i <= $max ; $i++) {
  247.             if (defined $dbline{$i}) {
  248.             $dbline{$i} =~ s/^[^\0]+//;
  249.             if ($dbline{$i} =~ s/^\0?$//) {
  250.                 delete $dbline{$i};
  251.             }
  252.             }
  253.         }
  254.         next; };
  255.         $cmd =~ /^L$/ && do {
  256.         for ($i = 1; $i <= $max; $i++) {
  257.             if (defined $dbline{$i}) {
  258.             &outstr("$i:  " . $dbline[$i]);
  259.             ($stop,$action) = split(/\0/, $dbline{$i});
  260.             &outstr("  break if (" . $stop . ")\n")
  261.                 if $stop;
  262.             &outstr("  action:  " . $action . "\n")
  263.                 if $action;
  264.             last if $signal;
  265.             }
  266.         }
  267.         next; };
  268.         $cmd =~ /^b\s*(['A-Za-z_]['\w]*)\s*(.*)/ && do {
  269.         $subname = $1;
  270.         $cond = $2 || '1';
  271.         $subname = "$package'" . $subname unless $subname =~ /'/;
  272.         $subname = "main" . $subname if substr($subname,0,1) eq "'";
  273.         ($filename,$i) = split(/[:-]/, $sub{$subname});
  274.         if ($i) {
  275.             *dbline = "_<$filename";
  276.             ++$i while $dbline[$i] == 0 && $i < $#dbline;
  277.             $dbline{$i} =~ s/^[^\0]*/$cond/;
  278.         } else {
  279.             &outstr("Subroutine $subname not found.\n");
  280.         }
  281.         next; };
  282.         $cmd =~ /^b\s*(\d*)\s*(.*)/ && do {
  283.         $i = ($1?$1:$line);
  284.         $cond = $2 || '1';
  285.         if ($dbline[$i] == 0) {
  286.             &outstr("Line $i not breakable.\n");
  287.         } else {
  288.             $dbline{$i} =~ s/^[^\0]*/$cond/;
  289.         }
  290.         next; };
  291.         $cmd =~ /^d\s*(\d+)?/ && do {
  292.         $i = ($1?$1:$line);
  293.         $dbline{$i} =~ s/^[^\0]*//;
  294.         delete $dbline{$i} if $dbline{$i} eq '';
  295.         next; };
  296.         $cmd =~ /^A$/ && do {
  297.         for ($i = 1; $i <= $max ; $i++) {
  298.             if (defined $dbline{$i}) {
  299.             $dbline{$i} =~ s/\0[^\0]*//;
  300.             delete $dbline{$i} if $dbline{$i} eq '';
  301.             }
  302.         }
  303.         next; };
  304.         $cmd =~ /^<\s*(.*)/ && do {
  305.         $pre = do action($1);
  306.         next; };
  307.         $cmd =~ /^>\s*(.*)/ && do {
  308.         $post = do action($1);
  309.         next; };
  310.         $cmd =~ /^a\s*(\d+)(\s+(.*))?/ && do {
  311.         $i = $1;
  312.         if ($dbline[$i] == 0) {
  313.             &outstr("Line $i may not have an action.\n");
  314.         } else {
  315.             $dbline{$i} =~ s/\0[^\0]*//;
  316.             $dbline{$i} .= "\0" . do action($3);
  317.         }
  318.         next; };
  319.         $cmd =~ /^n$/ && do {
  320.         $single = 2;
  321.         $laststep = $cmd;
  322.         last; };
  323.         $cmd =~ /^s$/ && do {
  324.         $single = 1;
  325.         $laststep = $cmd;
  326.         last; };
  327.         $cmd =~ /^c\s*(\d*)\s*$/ && do {
  328.         $i = $1;
  329.         if ($i) {
  330.             if ($dbline[$i] == 0) {
  331.                 &outstr("Line $i not breakable.\n");
  332.             next;
  333.             }
  334.             $dbline{$i} =~ s/(\0|$)/;9$1/;    # add one-time-only b.p.
  335.         }
  336.         for ($i=0; $i <= $#stack; ) {
  337.             $stack[$i++] &= ~1;
  338.         }
  339.         last; };
  340.         $cmd =~ /^r$/ && do {
  341.         $stack[$#stack] |= 2;
  342.         last; };
  343.         $cmd =~ /^T$/ && do {
  344.         local($p,$f,$l,$s,$h,$a,@a,@sub);
  345.         for ($i = 1; ($p,$f,$l,$s,$h,$w) = caller($i); $i++) {
  346.             @a = @args;
  347.             for (@a) {
  348.             if (/^StB\000/ && length($_) == length($_main{'_main'})) {
  349.                 $_ = sprintf("%s",$_);
  350.             }
  351.             else {
  352.                 s/'/\\'/g;
  353.                 s/([^\0]*)/'$1'/ unless /^-?[\d.]+$/;
  354.                 s/([\200-\377])/sprintf("M-%c",ord($1)&0177)/eg;
  355.                 s/([\0-\37\177])/sprintf("^%c",ord($1)^64)/eg;
  356.             }
  357.             }
  358.             $w = $w ? '@ = ' : '$ = ';
  359.             $a = $h ? '(' . join(', ', @a) . ')' : '';
  360.             push(@sub, "$w&$s$a from file $f line $l\n");
  361.             last if $signal;
  362.         }
  363.         for ($i=0; $i <= $#sub; $i++) {
  364.             last if $signal;
  365.             &outstr($sub[$i]);
  366.         }
  367.             next; };
  368.         $cmd =~ /^\/(.*)$/ && do {
  369.         $inpat = $1;
  370.         $inpat =~ s:([^\\])/$:$1:;
  371.         if ($inpat ne "") {
  372.             eval '$inpat =~ m'."\n$inpat\n";    
  373.             if ($@ ne "") {
  374.                 &outstr($@);
  375.                 next;
  376.             }
  377.             $pat = $inpat;
  378.         }
  379.         $end = $start;
  380.         eval '
  381.         for (;;) {
  382.             ++$start;
  383.             $start = 1 if ($start > $max);
  384.             last if ($start == $end);
  385.             if ($dbline[$start] =~ m'."\n$pat\n".'i) {
  386.             &outstr("$start:  " . $dbline[$start] . "\n");
  387.             last;
  388.             }
  389.         } ';
  390.         &outstr("/$pat/: not found\n") if ($start == $end);
  391.         next; };
  392.         $cmd =~ /^\?(.*)$/ && do {
  393.         $inpat = $1;
  394.         $inpat =~ s:([^\\])\?$:$1:;
  395.         if ($inpat ne "") {
  396.             eval '$inpat =~ m'."\n$inpat\n";    
  397.             if ($@ ne "") {
  398.                 &outstr($@);
  399.                 next;
  400.             }
  401.             $pat = $inpat;
  402.         }
  403.         $end = $start;
  404.         eval '
  405.         for (;;) {
  406.             --$start;
  407.             $start = $max if ($start <= 0);
  408.             last if ($start == $end);
  409.             if ($dbline[$start] =~ m'."\n$pat\n".'i) {
  410.             &outstr("$start:  " . $dbline[$start] . "\n");
  411.             last;
  412.             }
  413.         } ';
  414.         &outstr("?$pat?: not found\n") if ($start == $end);
  415.         next; };
  416.         $cmd =~ /^!+\s*(-)?(\d+)?$/ && do {
  417.         pop(@hist) if length($cmd) > 1;
  418.         $i = ($1?($#hist-($2?$2:1)):($2?$2:$#hist));
  419.         $cmd = $hist[$i] . "\n";
  420.         &outstr($cmd);
  421.         redo; };
  422.         $cmd =~ /^!(.+)$/ && do {
  423.         $pat = "^$1";
  424.         pop(@hist) if length($cmd) > 1;
  425.         for ($i = $#hist; $i; --$i) {
  426.             last if $hist[$i] =~ $pat;
  427.         }
  428.         if (!$i) {
  429.             &outstr("No such command!\n\n");
  430.             next;
  431.         }
  432.         $cmd = $hist[$i] . "\n";
  433.         &outstr($cmd);
  434.         redo; };
  435.         $cmd =~ /^H\s*(-(\d+))?/ && do {
  436.         $end = $2?($#hist-$2):0;
  437.         $hist = 0 if $hist < 0;
  438.         for ($i=$#hist; $i>$end; $i--) {
  439.             &outstr("$i: " . $hist[$i] . "\n")
  440.             unless $hist[$i] =~ /^.?$/;
  441.         };
  442.         next; };
  443.         $cmd =~ /^p\b/ && do {
  444.         if ($cmd =~ /^p$/) {
  445.             &outstr($_);
  446.         } elsif ($cmd =~ /^p\s+(.*)/) {
  447.             $evalarg = "&DB'outstr($1)"; &eval;
  448.         };
  449.         &outstr("\n");
  450.         next; };
  451.         $cmd =~ /^=/ && do {
  452.         if (local($k,$v) = ($cmd =~ /^=\s*(\S+)\s+(.*)/)) {
  453.             $alias{$k}="s~$k~$v~";
  454.             &outstr("$k = $v\n");
  455.         } elsif ($cmd =~ /^=\s*$/) {
  456.             foreach $k (sort keys(%alias)) {
  457.             if (($v = $alias{$k}) =~ s~^s\~$k\~(.*)\~$~$1~) {
  458.                 &outstr("$k = $v\n");
  459.             } else {
  460.                 &outstr("$k  $alias{$k}\n");
  461.             };
  462.             };
  463.         };
  464.         next; };
  465.         $evalarg = $cmd; &eval;
  466.         &outstr("\n");
  467.     }
  468.     if ($post) {
  469.         $evalarg = $post; &eval;
  470.     }
  471.     }
  472.     ($@, $!, $[, $,, $/, $\) = @saved;
  473. }
  474.  
  475. sub save {
  476.     @saved = ($@, $!, $[, $,, $/, $\);
  477.     $[ = 0; $, = ""; $/ = "\n"; $\ = "";
  478. }
  479.  
  480. # The following takes its argument via $evalarg to preserve current @_
  481.  
  482. sub eval {
  483.     eval "$usercontext $evalarg; &DB'save";
  484.     &outstr($@) if $@;
  485. }
  486.  
  487. sub action {
  488.     local($action) = @_;
  489.     while ($action =~ s/\\$//) {
  490.     &outstr("+ ");
  491.     $action .= &gets;
  492.     }
  493.     $action;
  494. }
  495.  
  496. sub gets {
  497.     local($.);
  498.     local($buf) = ' ' x 255;
  499.     local($regs) = syscall("OS_ReadLine",$buf,255,32,127);
  500.  
  501.     if ($regs) {
  502.     local($len) = unpack('x4 I',$regs);
  503.     $buf = substr($buf,0,$len) . "\n";
  504.     $buf;
  505.     }
  506.     else {
  507.     undef;
  508.     }
  509. }
  510.  
  511. sub catch {
  512.     $signal = 1;
  513. }
  514.  
  515. sub sub {
  516.     push(@stack, $single);
  517.     $single &= 1;
  518.     $single |= 4 if $#stack == $deep;
  519.     if (wantarray) {
  520.     @i = &$sub;
  521.     $single |= pop(@stack);
  522.     @i;
  523.     }
  524.     else {
  525.     $i = &$sub;
  526.     $single |= pop(@stack);
  527.     $i;
  528.     }
  529. }
  530.  
  531. sub outstr {
  532.     local($_) = join('',@_);
  533.  
  534.     s/\n/\r\n/g;
  535.     print DB'OUT $_;
  536. }
  537.  
  538. $single = 1;            # so it stops on first executable statement
  539. @hist = ('?');
  540. $SIG{'INT'} = "DB'catch";
  541. $deep = 100;            # warning if stack gets this deep
  542. $window = 10;
  543. $preview = 3;
  544.  
  545. @stack = (0);
  546. @args = @ARGV;
  547. for (@args) {
  548.     s/'/\\'/g;
  549.     s/(.*)/'$1'/ unless /^-?[\d.]+$/;
  550. }
  551.  
  552. if (-f $ENV{'Perl$DBInit'}) {
  553.     do $ENV{'Perl$DBInit'};
  554. }
  555.  
  556. 1;
  557.